home *** CD-ROM | disk | FTP | other *** search
/ The PC-SIG Library 10 / The PC-Sig Library - Shareware for the IBM PC and Compatibles (PC-SIG)(Tenth Edition Disks 1-2804)(1991).iso / PC_SIGCD / 20 / 5 / DISK2058.ZIP / UNFAST.EXE / COMPF.F < prev    next >
Text File  |  1980-01-01  |  13KB  |  735 lines
  1.  
  2. ;== Compress .F or .ASM files into .FX/.AX =================================
  3.  
  4. #inpend=0
  5. #short
  6. unsigned ld,ln,flen,nlen,lm,nn,words1,recs1,olm,users,useg,len
  7. var32 seeka
  8.  
  9. fastrecs=fast1:fastrecs=(fast2-fastrecs)/10
  10. asmrecs=asm1:asmrecs=(asm2-asmrecs)/10
  11.  
  12. ds=dta segment:do=dta offset
  13. files=0
  14.  
  15. proc pn(pm)
  16.     {
  17.     l=15
  18.     while peekb pm print bios chr peekb pm;:pm++:l--
  19.     repeat l print bios " ";
  20.     }
  21.  
  22. on error
  23.     {
  24.     print bios
  25.     error msg "\dos.err"
  26.     print bios "!":stop
  27.     }
  28. on break error 999
  29.  
  30. ;== Compression routines ===================================================
  31.  
  32. work ? 30
  33. word ? 30
  34.  
  35. const userx=2730
  36. const t_user=250,t_over=251,t_equal0=252,t_space4=253,t_extend=254,t_newline=255
  37.  
  38. proc user_word
  39.     {
  40.     pop drop    ;Drop caller.
  41.     if len<4 then return len-1
  42.  
  43.     u=findbin(word,useg,0,users,24,22)
  44.     if u then
  45.     {
  46.     u--
  47.     pokeb work,t_user
  48.     poke work+1,useg[u*24+22]
  49.     return 3
  50.     }
  51.     else
  52.     {
  53.     if users<userx then
  54.         {
  55.         sfind=(find_bin_put-1)*24
  56.         moveb users*24-sfind from useg|sfind to useg|sfind+24
  57.         moveb 22 from word to useg|sfind
  58.         useg[sfind+22]=olm
  59.         users++
  60.         }
  61.     return len-1
  62.     }
  63.     }
  64.  
  65. function make_token ;ld[lm]
  66.     {
  67.     olm=lm
  68.     c=ld[lm]:lm++
  69.     if c=0a0dh then lm++:pokeb work,t_newline:return 1
  70.     if c=303dh then lm++:pokeb work,t_equal0:return 1
  71.     if c=2020h then
  72.     {
  73.     if ld[lm+1]=2020h then lm+=3:pokeb work,t_space4:return 1
  74.     }
  75.     c1=low c
  76.     if c1>127 then pokeb work,t_over:pokeb work+1,c1:return 2
  77.  
  78.     #long
  79.     if (c1>='a') and (c1<'z') then
  80.     {
  81.     #short
  82.     moveb 23 from ld|lm-1 to work
  83.     fillb 23 from word with ' '
  84.     x=word:len=0:k=work
  85.     repeat 23
  86.         {
  87.         xc=peekb k:k++
  88.         len++
  89.         if (xc>127) or (peekb (septs+xc)=0) then goto make_check
  90.         lm++
  91.         pokeb x,xc:x++
  92.         }
  93.     lm--
  94.     return 23   ;Unknown word, too long.
  95.  
  96.     make_check:
  97.     lm--
  98.     if len<=11 then
  99.         {
  100.         n=findbin(word,reg cs,words1,recs1,10,10)
  101.         if n=0 then user_word
  102.         }
  103.     else user_word
  104.     n--
  105.     if n<122 then
  106.         {
  107.         pokeb work,n+128:return 1
  108.         }
  109.     else
  110.         {
  111.         pokeb work,t_extend:pokeb work+1,n:return 2
  112.         }
  113.     }
  114.  
  115.     pokeb work,c
  116.     return 1
  117.     }
  118.  
  119. function undo_token ;ld[lm]
  120.     {
  121.     c=ln[nn]b:nn++
  122.     if c=t_newline then poke work,0a0dh:return 2
  123.     if c=t_equal0 then poke work,303dh:return 2
  124.     if c=t_space4 then fill 2 from work with 2020h:return 4
  125.     if c=t_over then pokeb work,ln[nn]b:nn++:return 1
  126.     #long
  127.     if c=t_user then
  128.     {
  129.     #short
  130.     c=ln[nn]:nn+=2
  131.     moveb 23 from ld|c to work
  132.     len=0
  133.     repeat 23
  134.         {
  135.         c=peekb (work+len)
  136.         if (c>127) or (peekb (septs+c)=0) then return len
  137.         len++
  138.         }
  139.     return 23
  140.     }
  141.     if c=t_extend then
  142.     {
  143.     n=ln[nn]b:nn++
  144.     goto ext_common
  145.     }
  146.     if c>127 then
  147.     {
  148.     n=c-128
  149.     ext_common:
  150.     m=words1+10*n
  151.     moveb 10 from m to work
  152.     pokeb work+10,' '
  153.     n=searchb 11 from work for ' '
  154.  
  155.     return n-work
  156.     }
  157.  
  158.     pokeb work,c
  159.     return 1
  160.     }
  161.  
  162. function file_compress
  163.     {
  164.     users=0
  165.     nn=0:lm=0
  166.     while lm<flen
  167.     {
  168.     l=make_token
  169.     moveb l from work to ln|nn
  170.     nn+=l
  171.     }
  172.     return nn
  173.     }
  174.  
  175. function file_uncompress
  176.     {
  177.     nn=0:lm=0
  178.     while nn<nlen
  179.     {
  180.     l=undo_token
  181.     moveb l from work to ld|lm
  182.     lm+=l
  183.     }
  184.     return lm
  185.     }
  186.  
  187. ;== File management etc. ===================================================
  188.  
  189. print bios cr lf "COMPRESS FAST & ASSEMBLER FILES (v1.1) by Peter Campbell." cr lf
  190. ld=allocate 4096    ;Load sector.
  191. ln=allocate 4096    ;New sector.
  192. useg=allocate 4096  ;User token segment.
  193.  
  194. print bios "File? (.F or .ASM for compress, .FX or .AX for uncompress) ";
  195. inputs name
  196. print bios
  197. if peekb (name+2)=0 then error 999
  198. ext=searchb 30 from name+2 for '.'
  199. if ext=0 then error 11
  200.  
  201. fe=peek (ext+1):f1=lcase low fe:f2=lcase high fe
  202. if f1='f' then fast=1:words1=fast1:recs1=fastrecs
  203.     else if f1='a' then fast=0:words1=asm1:recs1=asmrecs else error 87
  204. if (f2=0) or (f2='s') then compress=1
  205.     else if f2='x' then compress=0 else error 87
  206.  
  207. moveb 30 from name to dest
  208. m=dest+2
  209. while peekb m
  210.     {
  211.     if (peekb m='*') or (peekb m='?') then pokeb m,'_'
  212.     m++
  213.     }
  214.  
  215. if compress=0 then goto un_compress
  216.  
  217. shit1=dest+ext
  218. shit2=name
  219. poke shit1-shit2+2,'x'
  220. create #2,dest+2
  221.  
  222. find first name+2
  223. goto entry
  224.  
  225. forever
  226.     {
  227.     #errors off
  228.     find next
  229.     if error then goto dtotal
  230.     #errors on
  231.     entry:
  232.     moveb 17 from ds|do+26 to spec
  233.     open #1,spec+4
  234.     pn(spec+4):print bios
  235.  
  236.     flen=peek spec
  237.     rn=read #1,flen to ld|0:if rn<>flen then error 13
  238.     nlen=file_compress
  239.     poke spec+2,nlen:write #2,15 from spec+2
  240.     write #2,nlen from ln|0
  241.  
  242.     close #1:files++
  243.     }
  244.  
  245. dtotal:
  246. close #2
  247. print bios cr lf "Compressed ";files;" file(s). New file: ";
  248. pn(dest+2):print bios
  249. stop
  250.  
  251. name:
  252. string 30
  253. dest:
  254. string 30
  255. spec:
  256. space 17
  257.  
  258. un_compress:
  259. open #2,dest+2
  260. seeka=0
  261.  
  262. unloop:
  263. seek #2,seeka
  264. rn=read #2,15 to spec:if rn=0 then
  265.     {
  266.     print bios cr lf "UnCompressed ";files;" file(s)."
  267.     close #2
  268.     stop
  269.     }
  270. if rn<>15 then error 13
  271. nlen=peek spec:seeka+=nlen+15
  272. pn(spec+2)
  273. #errors off
  274. open #1,spec+2
  275. #errors on
  276. if error=0 then
  277.     {
  278.     print bios "File exists! Overwrite? (y/n) ";
  279.     wait for keypressed:y=lcase key
  280.     if y=27 then error 999
  281.     if y<>'y' then print bios "no";:goto unnext
  282.     print bios "yes";
  283.     close #1
  284.     }
  285. else if error<>2 then error
  286.  
  287. create #1,spec+2
  288. files++
  289.  
  290. rn=read #2,nlen to ln|0:if rn<>nlen then error 13
  291. flen=file_uncompress
  292. write #1,flen from ld|0
  293.  
  294. unnext:
  295. print bios
  296. close #1
  297. goto unloop
  298.  
  299. ;== Word tables ============================================================
  300.  
  301. fast1:
  302. datab 'above     '
  303. datab 'abs     '
  304. datab 'allocate  '
  305. datab 'and     '
  306. datab 'asciiz     '
  307. datab 'at     '
  308. datab 'beep     '
  309. datab 'below     '
  310. datab 'break     '
  311. datab 'bright     '
  312. datab 'call     '
  313. datab 'carry     '
  314. datab 'cdisk     '
  315. datab 'change     '
  316. datab 'clocks     '
  317. datab 'close     '
  318. datab 'cls     '
  319. datab 'color     '
  320. datab 'colour     '
  321. datab 'com     '
  322. datab 'compare     '
  323. datab 'compareb  '
  324. datab 'const     '
  325. datab 'const32     '
  326. datab 'create     '
  327. datab 'curpos     '
  328. datab 'cursor     '
  329. datab 'curtoloc  '
  330. datab 'data     '
  331. datab 'datab     '
  332. datab 'deallocate'
  333. datab 'debug     '
  334. datab 'delete     '
  335. datab 'digits     '
  336. datab 'dim     '
  337. datab 'dimb     '
  338. datab 'dir     '
  339. datab 'disable     '
  340. datab 'dos     '
  341. datab 'dta     '
  342. datab 'duration  '
  343. datab 'else     '
  344. datab 'enable     '
  345. datab 'endcode     '
  346. datab 'endfor     '
  347. datab 'endif     '
  348. datab 'entry     '
  349. datab 'error     '
  350. datab 'errors     '
  351. datab 'errorv     '
  352. datab 'execute     '
  353. datab 'fill     '
  354. datab 'fillb     '
  355. datab 'find     '
  356. datab 'flash     '
  357. datab 'fname     '
  358. datab 'for     '
  359. datab 'forever     '
  360. datab 'free     '
  361. datab 'from     '
  362. datab 'function  '
  363. datab 'getint     '
  364. datab 'gosub     '
  365. datab 'goto     '
  366. datab 'halt     '
  367. datab 'handle     '
  368. datab 'handle     '
  369. datab 'hgraphics '
  370. datab 'high     '
  371. datab 'hit     '
  372. datab 'htext     '
  373. datab 'if     '
  374. datab 'ihere     '
  375. datab 'in     '
  376. datab 'include     '
  377. datab 'indoso     '
  378. datab 'indoss     '
  379. datab 'ink     '
  380. datab 'inline     '
  381. datab 'inpend     '
  382. datab 'input     '
  383. datab 'inputb     '
  384. datab 'inputh     '
  385. datab 'inputhb     '
  386. datab 'inputs     '
  387. datab 'int     '
  388. datab 'iret     '
  389. datab 'jump     '
  390. datab 'key     '
  391. datab 'keypressed'
  392. datab 'keyscan     '
  393. datab 'lcase     '
  394. datab 'let     '
  395. datab 'line     '
  396. datab 'load     '
  397. datab 'locate     '
  398. datab 'locpos     '
  399. datab 'loctocur  '
  400. datab 'long     '
  401. datab 'low     '
  402. datab 'lprint     '
  403. datab 'lprintb     '
  404. datab 'lprinth     '
  405. datab 'lprinthb  '
  406. datab 'make     '
  407. datab 'menu     '
  408. datab 'mod     '
  409. datab 'mode     '
  410. datab 'modify     '
  411. datab 'mono     '
  412. datab 'move     '
  413. datab 'moveb     '
  414. datab 'next     '
  415. datab 'noise     '
  416. datab 'not     '
  417. datab 'null     '
  418. datab 'on     '
  419. datab 'open     '
  420. datab 'or     '
  421. datab 'out     '
  422. datab 'page     '
  423. datab 'palette     '
  424. datab 'paper     '
  425. datab 'para     '
  426. datab 'peek     '
  427. datab 'peekb     '
  428. datab 'plot     '
  429. datab 'point     '
  430. datab 'poke     '
  431. datab 'pokeb     '
  432. datab 'pop     '
  433. datab 'popall     '
  434. datab 'print     '
  435. datab 'printb     '
  436. datab 'printh     '
  437. datab 'printhb     '
  438. datab 'printm     '
  439. datab 'prints     '
  440. datab 'proc     '
  441. datab 'procedure '
  442. datab 'psp     '
  443. datab 'push     '
  444. datab 'pushall     '
  445. datab 'randomize '
  446. datab 'read     '
  447. datab 'readb     '
  448. datab 'receive     '
  449. datab 'reclen     '
  450. datab 'reg     '
  451. datab 'remove     '
  452. datab 'rename     '
  453. datab 'repeat     '
  454. datab 'reset     '
  455. datab 'restore     '
  456. datab 'retf     '
  457. datab 'return     '
  458. datab 'rleft     '
  459. datab 'rleftz     '
  460. datab 'rnd     '
  461. datab 'rright     '
  462. datab 'rrightz     '
  463. datab 'save     '
  464. datab 'scan     '
  465. datab 'scrchr     '
  466. datab 'screen     '
  467. datab 'scroll     '
  468. datab 'search     '
  469. datab 'searchb     '
  470. datab 'seek     '
  471. datab 'select     '
  472. datab 'send     '
  473. datab 'setdos     '
  474. datab 'setint     '
  475. datab 'shape     '
  476. datab 'shell     '
  477. datab 'short     '
  478. datab 'sound     '
  479. datab 'space     '
  480. datab 'sppos     '
  481. datab 'sprint     '
  482. datab 'sprintb     '
  483. datab 'sprinth     '
  484. datab 'sprinthb  '
  485. datab 'sprite     '
  486. datab 'stack     '
  487. datab 'step     '
  488. datab 'stop     '
  489. datab 'string     '
  490. datab 'swap     '
  491. datab 'terminate '
  492. datab 'test     '
  493. datab 'then     '
  494. datab 'timer     '
  495. datab 'to     '
  496. datab 'trace     '
  497. datab 'ucase     '
  498. datab 'unsigned  '
  499. datab 'usr     '
  500. datab 'var     '
  501. datab 'var32     '
  502. datab 'video     '
  503. datab 'wait     '
  504. datab 'while     '
  505. datab 'window     '
  506. datab 'with     '
  507. datab 'write     '
  508. datab 'xor     '
  509. fast2:
  510.  
  511. asm1:
  512. datab 'aaa     '
  513. datab 'aad     '
  514. datab 'aam     '
  515. datab 'aas     '
  516. datab 'adc     '
  517. datab 'adcb     '
  518. datab 'adcw     '
  519. datab 'add     '
  520. datab 'addb     '
  521. datab 'addw     '
  522. datab 'ah     '
  523. datab 'al     '
  524. datab 'and     '
  525. datab 'andb     '
  526. datab 'andw     '
  527. datab 'ax     '
  528. datab 'bh     '
  529. datab 'bl     '
  530. datab 'bp     '
  531. datab 'bx     '
  532. datab 'call     '
  533. datab 'callf     '
  534. datab 'cbw     '
  535. datab 'ch     '
  536. datab 'cl     '
  537. datab 'clc     '
  538. datab 'cld     '
  539. datab 'cli     '
  540. datab 'cmc     '
  541. datab 'cmp     '
  542. datab 'cmpb     '
  543. datab 'cmpsb     '
  544. datab 'cmpsw     '
  545. datab 'cmpw     '
  546. datab 'cs     '
  547. datab 'cwd     '
  548. datab 'cx     '
  549. datab 'daa     '
  550. datab 'das     '
  551. datab 'db     '
  552. datab 'dec     '
  553. datab 'decb     '
  554. datab 'decw     '
  555. datab 'dh     '
  556. datab 'di     '
  557. datab 'div     '
  558. datab 'divb     '
  559. datab 'divw     '
  560. datab 'dl     '
  561. datab 'ds     '
  562. datab 'dw     '
  563. datab 'dx     '
  564. datab 'endif     '
  565. datab 'endp     '
  566. datab 'equ     '
  567. datab 'es     '
  568. datab 'esc     '
  569. datab 'hlt     '
  570. datab 'idiv     '
  571. datab 'idivb     '
  572. datab 'idivw     '
  573. datab 'if     '
  574. datab 'imul     '
  575. datab 'imulb     '
  576. datab 'imulw     '
  577. datab 'in     '
  578. datab 'inc     '
  579. datab 'incb     '
  580. datab 'include     '
  581. datab 'incw     '
  582. datab 'int     '
  583. datab 'into     '
  584. datab 'iret     '
  585. datab 'ja     '
  586. datab 'jae     '
  587. datab 'jb     '
  588. datab 'jbe     '
  589. datab 'jc     '
  590. datab 'jcxz     '
  591. datab 'je     '
  592. datab 'jg     '
  593. datab 'jge     '
  594. datab 'jl     '
  595. datab 'jle     '
  596. datab 'jmp     '
  597. datab 'jmpf     '
  598. datab 'jmps     '
  599. datab 'jna     '
  600. datab 'jnae     '
  601. datab 'jnb     '
  602. datab 'jnbe     '
  603. datab 'jnc     '
  604. datab 'jne     '
  605. datab 'jng     '
  606. datab 'jnge     '
  607. datab 'jnl     '
  608. datab 'jnle     '
  609. datab 'jno     '
  610. datab 'jnp     '
  611. datab 'jns     '
  612. datab 'jnz     '
  613. datab 'jo     '
  614. datab 'jp     '
  615. datab 'jpe     '
  616. datab 'js     '
  617. datab 'jz     '
  618. datab 'lahf     '
  619. datab 'lds     '
  620. datab 'lea     '
  621. datab 'les     '
  622. datab 'lock     '
  623. datab 'lodsb     '
  624. datab 'lodsw     '
  625. datab 'loop     '
  626. datab 'loope     '
  627. datab 'loopne     '
  628. datab 'loopnz     '
  629. datab 'loopz     '
  630. datab 'mov     '
  631. datab 'movb     '
  632. datab 'movsb     '
  633. datab 'movsw     '
  634. datab 'movw     '
  635. datab 'mul     '
  636. datab 'mulb     '
  637. datab 'mulw     '
  638. datab 'neg     '
  639. datab 'negb     '
  640. datab 'negw     '
  641. datab 'nop     '
  642. datab 'not     '
  643. datab 'notb     '
  644. datab 'notw     '
  645. datab 'offset     '
  646. datab 'or     '
  647. datab 'orb     '
  648. datab 'org     '
  649. datab 'orw     '
  650. datab 'out     '
  651. datab 'para     '
  652. datab 'pop     '
  653. datab 'popf     '
  654. datab 'proc     '
  655. datab 'push     '
  656. datab 'pushf     '
  657. datab 'rcl     '
  658. datab 'rclb     '
  659. datab 'rclw     '
  660. datab 'rcr     '
  661. datab 'rcrb     '
  662. datab 'rcrw     '
  663. datab 'rep     '
  664. datab 'repe     '
  665. datab 'repne     '
  666. datab 'repnz     '
  667. datab 'repz     '
  668. datab 'ret     '
  669. datab 'retf     '
  670. datab 'rol     '
  671. datab 'rolb     '
  672. datab 'rolw     '
  673. datab 'ror     '
  674. datab 'rorb     '
  675. datab 'rorw     '
  676. datab 'sahf     '
  677. datab 'sal     '
  678. datab 'salb     '
  679. datab 'salw     '
  680. datab 'sar     '
  681. datab 'sarb     '
  682. datab 'sarw     '
  683. datab 'sbb     '
  684. datab 'sbbb     '
  685. datab 'sbbw     '
  686. datab 'scasb     '
  687. datab 'scasw     '
  688. datab 'shl     '
  689. datab 'shlb     '
  690. datab 'shlw     '
  691. datab 'shr     '
  692. datab 'shrb     '
  693. datab 'shrw     '
  694. datab 'si     '
  695. datab 'sp     '
  696. datab 'ss     '
  697. datab 'stc     '
  698. datab 'std     '
  699. datab 'sti     '
  700. datab 'stosb     '
  701. datab 'stosw     '
  702. datab 'sub     '
  703. datab 'subb     '
  704. datab 'subw     '
  705. datab 'test     '
  706. datab 'testb     '
  707. datab 'testw     '
  708. datab 'wait     '
  709. datab 'xchg     '
  710. datab 'xchgb     '
  711. datab 'xchgw     '
  712. datab 'xlat     '
  713. datab 'xor     '
  714. datab 'xorb     '
  715. datab 'xorw     '
  716. asm2:
  717.  
  718. septs:
  719. datab 1,1,1,1,1,1,1,1 ;0
  720. datab 1,0,0,1,1,0,1,1 ;8
  721. datab 1,1,1,1,1,1,1,1 ;16
  722. datab 1,1,0,0,1,1,1,1 ;24
  723. datab 0,1,0,0,1,1,1,0 ;32
  724. datab 0,0,0,0,0,0,0,0 ;40
  725. datab 1,1,1,1,1,1,1,1 ;48
  726. datab 1,1,0,0,0,0,0,0 ;56
  727. datab 0,1,1,1,1,1,1,1 ;64
  728. datab 1,1,1,1,1,1,1,1 ;72
  729. datab 1,1,1,1,1,1,1,1 ;80
  730. datab 1,1,1,0,1,0,1,1 ;88
  731. datab 1,1,1,1,1,1,1,1 ;96
  732. datab 1,1,1,1,1,1,1,1 ;104
  733. datab 1,1,1,1,1,1,1,1 ;112
  734. datab 1,1,1,0,0,0,1,1 ;120
  735.